home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The 640 MEG Shareware Studio 2
/
The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO
/
pascal
/
tpb4_src.zip
/
MSGMISC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-09-13
|
15KB
|
465 lines
{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault
Last modified :: 9-11-88 12:18 pm
}
{$R-} {Range checking off}
{$B-} {Boolean complete evaluation off}
{$S-} {Stack checking off}
{$I+} {I/O checking on}
{$N-} {No numeric coprocessor}
Unit MsgMisc;
Interface
Uses
TPCrt, Globals, Core1, NetMisc,
TPSTRING, TPDOS, Core2, MsgDir;
procedure mesg_build_index(mesg_area : Byte);
procedure Articles;
procedure list_file(fname : DosFileName; Dirspec : StrPr);
procedure mesg_area_change(req : DosFileName);
procedure mesg_delete;
{==========================================================================}
Implementation
{ Scan summary file and build message index list. Messages are tied to the
current message area. All messages are accessible in mesg_area #0 (SYSTEM).}
procedure mesg_build_index(mesg_area : Byte);
var
This : MesgPtr;
begin
while MesgBase <> nil do { Delete old messages }
begin
This := MesgBase;
MesgBase := MesgBase^.next; { Go to next on list }
Dispose(This) { Reclaim space }
end;
msg_all := 0;
msg_ind := 0;
msg_aut := 0;
msg_sys := 0;
msg_hi := 0;
msg_lo := 30000;
Seek(summ_file, 1);
while not EoF(summ_file) do
with summ_rec do
begin
Read(summ_file, summ_rec);
if ((status <> deleted) and (status <> restricted) and (Area = mesg_area)) or (
mesg_area = 0) then
begin
if msg_lo > num then
msg_lo := num;
if num > msg_hi then
msg_hi := num;
end;
if (status = public) and ((Area = mesg_area) or (mesg_area = 0)) {Public message}
then
if (user_loc = user_to) or ((user_to = 0) and
(num > user_rec.lasthi) and (user_from = 1)) then
begin
Inc(msg_ind);
Inc(msg_all); {add to public count too}
mesg_insert(1);
end
else if user_loc = user_from then
begin
Inc(msg_aut);
Inc(msg_all);
mesg_insert(2);
end
else
begin
Inc(msg_all);
mesg_insert(0)
end
else if (status <> deleted) and (user_loc = user_to) and ((Area = mesg_area) or (
mesg_area = 0)) then
begin { Private message }
Inc(msg_ind);
mesg_insert(1)
end
else if (status <> deleted) and (user_loc = user_from) and ((Area = mesg_area) or (
mesg_area = 0)) then
begin { Author of message }
Inc(msg_aut);
mesg_insert(2)
end
else if mesg_area = 0 then
begin { Sysop can view all messages }
Inc(msg_sys);
mesg_insert(3)
end
end;
if msg_lo >= 29999 then
msg_lo := 0;
summ_rec.user_from := 0
end;
procedure list_file(fname : DosFileName;
Dirspec : StrPr);
var
work : StrStd;
Tfile : Text;
ln_count : Integer;
OK : Boolean;
begin
abort := False;
SetSect(Dirspec);
Assign(Tfile, fname);
{$I-}
Reset(Tfile); {$I+}
if IoResult = 0 then
begin
ln_count := 1;
while (not EoF(Tfile)) and (Online) and (not brk) do
begin
ReadLn(Tfile, work);
WriteLn(Com, work);
if (user_rec.lines <> 99) and (not nonstop) then
begin
Inc(ln_count);
if ln_count mod user_rec.lines = 0 then
pause;
end;
end;
end
else
WriteLn(Com, 'File not available.');
{$I-}
Close(Tfile);
{$I+}
OK := (IoResult = 0);
SetSect(HomName);
end;
procedure Articles;
var
This : ArtPtr;
num : Integer;
Dirspec : StrPr;
begin
if Artbase <> nil then
begin
repeat
This := Artbase;
WriteLn(Com);
WriteLn(Com, 'ARTICLES AVAILABLE FOR VIEWING');
WriteLn(Com);
while This <> nil do
begin
if user_rec.access >= This^.ArtAccs then
WriteLn(Com, This^.Artnum, ' ', This^.ArtDesc);
This := This^.next;
end;
WriteLn(Com);
num := strint(prompt('Number of Article to read [CR to exit]', 3, 'E'));
This := Artbase;
while (This <> nil) and (This^.Artnum <> num) do
This := This^.next;
if (This^.Artnum = num) and (user_rec.access >= This^.ArtAccs) then
begin
Dirspec := This^.Artdrive+':\';
if (Length(HomName) > 3) and (Dirspec = HomDrv) then
begin
Dirspec := Dirspec+Copy(HomName, 4, Length(HomName));
Dirspec := Dirspec+'\';
end;
Dirspec := Dirspec+'ARTICLES';
list_file(This^.ArtName, Dirspec);
pause;
end;
until (not Online) or (num = 0);
end
else
begin
WriteLn(Com);
WriteLn(Com, ' Articles are not available at this time.');
WriteLn(Com);
end;
end;
procedure mesg_area_change(req : DosFileName);
{ Change message area }
const
col_width = 16;
var
col_count,
col_limit,
conf_num,
line_count,
area_count, i : Integer;
This : AreaPtr;
pr, echo_rec : StrPr;
temp : Str14;
SameArea,
found, OK : Boolean;
procedure display_short;
var
pad_count : Byte;
wrap_on_next : Boolean;
begin
WriteLn(Com);
abort := False;
col_count := 0;
This := AreaBase;
Write(Com, hi, yellow);
area_count := 1;
while (not brk) and (This <> nil) do
begin
conf_num := This^.AreaConf and 7;
if (user_rec.access >= This^.AreaAccs) or (test_bit(user_rec.
conf_flags, conf_num)) then
begin
Inc(col_count);
wrap_on_next := (0 = col_count mod col_limit);
if wrap_on_next then
pad_count := 1
else
pad_count := 13;
temp := This^.AreaName;
if temp[1] = '-' then Delete(temp, 1, 1);
Write(Com, yellow, intstr(area_count, 2), cyan, ' ',
pad(temp, pad_count));
if wrap_on_next then
WriteLn(Com);
Inc(area_count)
end;
This := This^.next;
end;
Write(Com, cyan);
if 0 <> col_count mod col_limit then
WriteLn(Com);
WriteLn(Com);
end;
procedure display_long;
begin
WriteLn(Com);
line_count := 2;
This := AreaBase;
area_count := 1;
while (not brk) and (This <> nil) do
begin
conf_num := This^.AreaConf and 7;
if (user_rec.access >= This^.AreaAccs) or (test_bit(user_rec.conf_flags,
conf_num)) then
begin
temp := This^.AreaName;
if temp[1] = '-' then Delete(temp, 1, 1);
temp := intstr(area_count, 2)+' '+temp;
WriteLn(Com, hi, yellow, pad(temp, 13), low, green, This^.AreaDesc);
Inc(area_count);
end;
This := This^.next;
if user_rec.lines <> 99 then
begin
Inc(line_count);
if line_count mod user_rec.lines = 0 then
pause;
end;
end;
Write(Com, hi, cyan);
WriteLn(Com);
end;
begin {mesg_area_change}
SameArea := False;
col_limit := max(1, user_rec.columns div col_width);
pr := white+'Enter Area Name or #'+cyan;
if req = '' then
begin
WriteLn(Com);
req := prompt(pr, 12, 'ES?M');
end;
if req = ' ' then
begin
req := AreaReq;
SameArea := True;
end;
while (req <> '') and (Online) and (not SameArea) do
begin
This := AreaBase;
if (req = '?') or (req = '/') then
begin
WriteLn(Com);
WriteLn(Com, 'Available message areas:');
display_short;
repeat
req := prompt(pr+' ["?" for Descriptions]', 12, 'ES?');
if (req = '?') or (req = '/') then
display_long;
until (req <> '?') and (req <> '/');
if req = ' ' then
begin
req := AreaReq; {default to current}
SameArea := True;
end;
end
else if req <> '' then
begin
area_count := 1;
repeat
conf_num := This^.AreaConf and 7;
found := (This^.AreaName = req) or (strint(req) = area_count);
if (not((user_rec.access >= This^.AreaAccs) or
(test_bit(user_rec.conf_flags, conf_num)))) then
begin
Dec(area_count);
found := False
end;
if (not found) and (This^.AreaName[1] = '-') then
begin
temp := This^.AreaName;
Delete(temp, 1, 1);
found := (temp = req)
end;
if (not found) and (This <> nil) then
begin
This := This^.next;
Inc(area_count)
end;
until found or (This = nil);
if found and ((user_rec.access >= This^.AreaAccs) or (test_bit(
user_rec.conf_flags,
conf_num))) then
begin
if (not SameArea) then
begin
AreaSet := This^.Area;
AreaReq := This^.AreaName;
req := '';
if (AreaReq <> 'NETMAIL') and
(AreaReq[1] <> '-') then
begin
mesg_build_index(AreaSet);
mesg_directory;
end
else
begin
found := False;
i := 0;
Assign(echo_file, echo_name+ext);
{$I-}
Reset(echo_file) {$I+} ;
OK := (IoResult = 0);
if OK then
begin
while ((not EoF(echo_file)) and (not found)) do
begin
ReadLn(echo_file, echo_rec);
if Pos(AreaReq, echo_rec) <> 0 then
begin
msg_offset := i;
found := True
end
else
Inc(i);
end;
if (not found) then
begin
msg_offset := 0;
WriteLn(Com,
'Message counters are not maintained for this Area.');
end;
if msg_offset > 63 then msg_offset := 0;
mesg_directory;
Close(echo_file)
end
else
begin
WriteLn(Com, echo_name, ext, ' not found.');
WriteLn(Com, 'Please let the SysOp know.');
msg_offset := 0
end;
end;
end;
end
else
begin
WriteLn(Com, '"', req, '" not found. Available message areas:');
display_short;
repeat
req := prompt(pr+' ["?" for Descriptions]', 12, 'ES?');
if (req = '?') or (req = '/') then
display_long;
until (req <> '?') and (req <> '/');
if req = ' ' then
begin
req := AreaReq; {default to current}
SameArea := True;
end;
end
end
end
end;
procedure mesg_delete;
{ Delete the current message }
var
This : MesgPtr;
begin
summ_rec.status := deleted;
Seek(summ_file, Pred(FilePos(summ_file)));
Write(summ_file, summ_rec);
This := MesgCurr;
if MesgCurr = MesgBase then
begin
MesgCurr := MesgBase^.next;
MesgBase := MesgBase^.next;
Dispose(This)
end
else if MesgCurr <> nil then
begin
MesgCurr := MesgBase; { Find previous record }
while MesgCurr^.next <> This do
MesgCurr := MesgCurr^.next;
MesgCurr^.next := This^.next; { Make it point to next record }
if MesgLast = This then
MesgLast := MesgCurr;
MesgCurr := MesgCurr^.next;
Dispose(This)
end;
WriteLn(Com, 'Message #', summ_rec.num, ' deleted.')
end; {mesg_delete}
end. { of MSGMISC.PAS}
